TPUG - Toronto PET Users Group/TPUG Users Group CD/TPUG Users Group CD.iso/MSDOS/(m)aal/CUTFILE2.PAS

Pascal/Delphi Source File | 1987-10-11 | 6KB | 206 lines

PROGRAM Cutfile;

  {$U-}
  {$C-}
  {$I c:\pas\uti\util2.lib}
TYPE
  String50 = STRING[50];
CONST
  DataRecSize = 1;            (*  bytes *)
  DiskSpaceFree : Real = 360400.0; (* Maximum size on disk *)
VAR
  Datafile : FILE;
  OutFile : FILE;
  Byte1 : Byte;
  xzx : Char;
  RecsRead, RecsWrote, buffsize,
  NumberOfChunks : Integer;
  Chunk, Datafilesize,
  RecsAlreadyWritten : Real;
  NoMoreRecs, FileisDone : Boolean;
  DataArray : ARRAY[1..30000] OF Byte;
  FN : STRING[1];
  FN2 : STRING[2];
  Outfilename, Inputfilename,
  Destinationfilename : STRING[150];
  pnr, I, num, FileNum : Integer;

  FUNCTION FreeDiskSpace(Drive : Char) : Real;

  TYPE
    RegType = RECORD CASE Byte OF {Used for DOS calls.                 }
      1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer);
      2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
              END;

  VAR
    Regpack : RegType;        {record for MsDos call}

  BEGIN                       (* GetFreeDiskSpace*)
    WITH RegPack DO
      BEGIN                   (* With RegPack *)
        AH := $36;
        CASE UpCase(Drive) OF
          'A' : DL := 1;
          'B' : DL := 2;
          'C' : DL := 3;
          'D' : DL := 4;
          'E' : DL := 5;
          'F' : DL := 6;
          'G' : DL := 7;
          'H' : DL := 8;
          'I' : DL := 9;
          'J' : DL := 10;
        ELSE Dl := 0;
        END                   (* case *)
      END;                    (* With RegPack *)
    MsDos(regpack);
    WITH regpack DO
      BEGIN
        IF AX = $FFFF THEN    (* error has occured *)
          BEGIN
            WriteLn('Dos reports Invalid Drive or other error');
            WriteLn('Program Execution Terminated');
            Halt;             (*Program execution stops here*)
          END;
        FreeDiskSpace := 1.0*RegPack.AX*RegPack.BX*RegPack.CX*1.0;
      END;
  END;                        (* FreeDiskSpace *)


  FUNCTION ReadFileName(Description : String50) : String80;
    (**************************************************************************)
  VAR
    Infilename : String80;
    FileExists : Boolean;
  BEGIN
    REPEAT
      WriteLn('Please enter the name of the ', description, ' file ');
      ReadLn(infilename);
      IF Exist(infilename) THEN
        BEGIN
          FileExists := True;
        END
      ELSE
        BEGIN
          FileExists := False;
          WriteLn('File not Found!! Press any key or Ctrl C to abort');
          Read(Kbd, xzx);
        END;
    UNTIL (FileExists OR (Ord(xzx) = $03));
    IF Ord(xzx) = $03 THEN
      BEGIN
        WriteLn('Program Terminated');
        Halt;
      END;

    ReadFileName := Infilename;
  END;                        (* ReadFileName*)

  FUNCTION WriteFileName(Description : String50) : String80;
    (**************************************************************************)
  VAR
    Infilename : String80;
    FileExists : Boolean;
  BEGIN
    REPEAT
      WriteLn('Please enter the name of the ', description, ' file ');
      ReadLn(infilename);
      IF Exist(infilename) THEN
        FileExists := True
      ELSE
        BEGIN
          FileExists := False;
        END;
    UNTIL (NOT FileExists OR (Ord(infilename[1]) = $03));
    IF Ord(infilename[1]) = $03 THEN Halt;
    WriteFileName := Infilename;
  END;                        (* ReadFileName*)


  PROCEDURE WriteFile(FileNum : Integer; NumberOfBytesAvailable : Real);
    (**************************************************************************)
  BEGIN                       (*WriteFile*)
    IF FileNum < 10 THEN
      BEGIN
        Str(FileNum, FN);
        Outfilename := Destinationfilename+'.'+FN;
      END
    ELSE
      BEGIN
        Str(filenum, FN2);
        Outfilename := Destinationfilename+'.'+FN2;
      END;
    WriteLn('There are ', NumberOfBytesAvailable, ' available');
    WriteLn('Writing ', Outfilename);
    Assign(Outfile, Outfilename);
    Rewrite(outfile, 1);
    LongSeek(Datafile, RecsAlreadyWritten);
    IF NumberOfBytesAvailable > 30000 THEN
      Buffsize := 30000
    ELSE
      BuffSize := Trunc(NumberOfBytesAvailable);
    Chunk := 0;
    REPEAT
      BlockRead(datafile, DataArray, Buffsize, Recsread);
      BlockWrite(outfile, DataArray, RecsRead);
      chunk := RecsRead+Chunk;
      WriteLn('Read ', RecsRead:6, ' recs and wrote ', Chunk:6);
      IF Abs(NumberOfBytesAvailable-chunk) < 30000 THEN
        Buffsize := Trunc(NumberOfBytesAvailable-chunk);
    UNTIL ((chunk >= NumberOfBytesAvailable) OR (RecsRead < 1));
    RecsAlreadyWritten := RecsAlreadyWritten+Chunk;
    Close(outfile);
    IF RecsAlreadyWritten >= DataFileSize THEN
      FileIsDone := True
    ELSE
      FileIsDone := False;
  END;                        (* WriteFile *)

  PROCEDURE TransferFileToFloppies;
    (**************************************************************************)
  VAR
    I : Integer;
    Drive : Char;

  BEGIN                       (*TransferPartOfFile*)
    RecsAlreadyWritten := 0;
    Assign(datafile, inputfilename);
    Reset(datafile, 1);
    DataFileSize := LongFileSize(datafile);
    FOR I := 1 TO 3 DO
      BEGIN
        IF DestinationFileName[I] = ':' THEN
          BEGIN
            Drive := DestinationFileName[Pred(I)];
            i := 3
          END;
      END;
    FileNum := 1;
    REPEAT
      WriteLn('Please get Destination drive ready.. Press any key when ready');
      Read(Kbd, xzx);
      IF Ord(xzx) = $03 THEN
        BEGIN
          Close(datafile);
          Close(Outfile);
          WriteLn('Program Terminated by Ctrl C');
          Halt;
        END;
      DiskSpaceFree := FreeDiskSpace(Drive);
      WriteFile(FileNum, DiskSpaceFree);
      Filenum := Succ(fileNum);
    UNTIL FileIsDone;
    Close(Datafile);
  END;




BEGIN
  xzx := ' ';
  InputFileName := ReadFileName('input (include Extension)');
  DestinationFileName := WriteFileName('Destination (include path, no extension');
  TransferFileToFloppies;
END.